home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / stream.l < prev    next >
Text File  |  1989-07-12  |  35KB  |  840 lines
  1. ;;; -*- Mode:Lisp; Package:CLUEI; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1988 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;; To do:
  20. ;; 1. Need margins
  21.  
  22. ;;; Change History:
  23. ;;; ----------------------------------------------------------------------------
  24. ;;;  11/09/87   LGO    Created.
  25. ;;;  08/17/88    LGO    Added Common-Windows rubout-handler support
  26. ;;;  08/22/88   SLM     Display the text cursor position.
  27. ;;;  08/23/88   SLM     Toggle solid and hollow text cursor when input focus 
  28. ;;;  02/24/89    DNG    When using Explorer CLOS, enable instances of 
  29. ;;;            interactive-stream to accept flavor messages from the 
  30. ;;;            system I/O functions.
  31. ;;;  02/28/89   KK      Updated for CLUE 1.16
  32. ;;;  05/06/89    DNG    For the Explorer, update to use the stream generic functions 
  33. ;;;            in the TICLOS package, and add support for the :READ-CURSORPOS and 
  34. ;;;            :INCREMENT-CURSORPOS messages.
  35.  
  36.  
  37.  
  38. ;;;----------------------------------------------------------------------------+
  39. ;;;                                                                            |
  40. ;;;  WARNING: Non-portable code! A portable implementation of an interactive-  |
  41. ;;;  stream will not be possible until a standard generic function protocol    |
  42. ;;;  for Common Lisp streams has been defined. This implementation works       |
  43. ;;;  for Explorers and other Lisp machines. It may serve as an example for     |
  44. ;;;  other implementations as well.                                            |
  45. ;;;                                                                            |
  46. ;;;----------------------------------------------------------------------------+
  47.  
  48.  
  49.  
  50. (in-package 'cluei :use '(lisp xlib clos))
  51.  
  52. #+(and Explorer CLOS)
  53. (import '(ticlos:stream-clear-input
  54.       ticlos:stream-unread-char
  55.       ticlos:stream-listen
  56.       ticlos:stream-read-char
  57.       ticlos:stream-clear-output
  58.       ticlos:stream-write-char
  59.       ticlos:stream-write-string
  60.       ticlos:stream-fresh-line
  61.       ))
  62. (export '(interactive-stream
  63.       stream-clear-input
  64.       stream-unread-char
  65.       stream-listen
  66.       stream-peek-char
  67.       stream-read-char
  68.       stream-read-line
  69.       set-cursorpos
  70.       stream-clear-output
  71.       stream-move-cursor
  72.       stream-write-char
  73.       clear-line
  74.       clear-eol
  75.       stream-write-string
  76.       text-within-width
  77.       stream-fresh-line
  78.       draw-lozenged-string
  79.       simple-rubout-handler
  80.       with-input-editing
  81.       rubout-handler
  82.       get-rubout-handler-buffer
  83.       force-input
  84.       ))
  85.  
  86. (defcontact interactive-stream (contact #+(and Explorer CLOS) TICLOS:FUNDAMENTAL-CHARACTER-OUTPUT-STREAM
  87.                     #+(and Explorer CLOS) TICLOS:FUNDAMENTAL-CHARACTER-INPUT-STREAM)
  88.   ((gcontext :type (or null gcontext) :initform nil :reader stream-gcontext)
  89.    (font :type font :reader stream-font
  90.      :initform 'fixed)
  91.    (cursor-x :initform 0 :type integer :reader stream-cursor-x)       ; Cursor X
  92.    (cursor-y :initform 0 :type integer :reader stream-cursor-y)       ; Cursor Y
  93.    (line-height :initform 0 :type integer :accessor stream-line-height) ; rasters per character line.
  94.    (tab-width :initform 0 :type integer :accessor stream-tab-width)   ; Number of pixels in a tab
  95.    (lozenge-font :type font :accessor stream-lozenge-font
  96.          :initform 'micro)
  97.    (unreadp :type boolean :initform nil)    ; True if a character was unread (already echoed)
  98.    (more-height :initform t :type (or boolean card16) :accessor stream-more-height)
  99.                 ; When this is non-nil, Every time a new line is output, this is
  100.                 ; decremented by LINE-HEIGHT.  When this is less than zero,
  101.                 ; MORE-PROCESSING is called.  MORE-HEIGHT gets set to
  102.                 ; the value of (RESET-MORE-HEIGHT stream) in STREAM-READ-CHAR,
  103.                    ; STREAM-CLEAR-OUTPUT and :after REALIZE.
  104.    (rubout-handler-function :initform 'simple-rubout-handler       ; Rubbout handler function
  105.                 :accessor stream-rubout-handler-function)
  106.    (output-history-top :initform nil)       ; Points to the output history line at the top of the window
  107.    (output-history :initform nil)       ; Circular List of strings
  108.    (output-history-size :initform 100)
  109.    )
  110.   (:resources
  111.     gcontext
  112.     font
  113.     (event-mask :initform '(:exposure))
  114.     cursor-x cursor-y more-height line-height tab-width lozenge-font
  115.     rubout-handler-function output-history-size
  116.     (background :initform :black))
  117.   )
  118.  
  119. (define-resources
  120.   (* interactive-stream width) 400
  121.   (* interactive-stream height) 400
  122.   )
  123.  
  124. (defmethod initialize-instance :after ((self interactive-stream) &rest options &aux (between-line-spacing 1))
  125.   (declare (ignore options))
  126.   (with-slots ( output-history output-history-top output-history-size
  127.            gcontext cursor-y font line-height tab-width) (the interactive-stream self)
  128.     (when (zerop line-height)
  129.       (setf line-height (+ (max-char-ascent font) (max-char-descent font) between-line-spacing)))
  130.     (when (zerop cursor-y) (setf cursor-y (- line-height (max-char-descent font))))
  131.     (when (zerop tab-width)
  132.       (setf tab-width (* 8 (max-char-width font))))
  133.     (setf output-history (make-list output-history-size))
  134.     (setf (cdr (last output-history)) output-history) ;; Make circular
  135.     (setf (car output-history) (make-array 256 :fill-pointer 0 :element-type 'string-char))
  136.     (setf output-history-top output-history)
  137.     ))
  138.  
  139. (defmethod realize :after ((self interactive-stream))
  140.   ;; Ensure the gcontext is initialized
  141.   (with-slots (gcontext font background) self
  142.     (unless gcontext
  143.       (setf gcontext (create-gcontext :drawable self :font font
  144.                       :background background
  145.                       :foreground (logxor background 1)))))
  146.   (reset-more-height self))
  147.  
  148. (defevent interactive-stream :key-press stream-save-key)
  149. (defmethod stream-save-key ((stream interactive-stream))
  150.   (with-event (character display)
  151.     (let ((char character))
  152.       (when (characterp char)
  153.     (append-characters display char)))
  154.     t))
  155.  
  156. (defevent interactive-stream :focus-in (stream-display-cursor t))
  157. (defevent interactive-stream :focus-out (stream-display-cursor nil))
  158. (defmethod stream-display-cursor ((stream interactive-stream) fill-p)
  159.   (with-slots (gcontext cursor-x cursor-y) stream
  160.     (draw-cursor stream cursor-x cursor-y gcontext :erase-p t :fill-p (not fill-p))
  161.     (draw-cursor stream cursor-x cursor-y gcontext :fill-p fill-p)))
  162.  
  163. (defun draw-cursor (window cursor-x cursor-y gcontext &optional &key (fill-p t) (erase-p nil))
  164.   (let* ((font (gcontext-font gcontext))
  165.      (width (xlib:max-char-width font))
  166.      (height (+ (xlib:max-char-ascent font) (xlib:max-char-descent font)))
  167.      (rectangle-y (- cursor-y (xlib:max-char-ascent font))))
  168.     (when erase-p
  169.       (using-gcontext (gc :drawable window
  170.               :background (gcontext-foreground gcontext)
  171.               :foreground (gcontext-background gcontext))
  172.     (draw-rectangle window gc cursor-x rectangle-y width height fill-p))
  173.       (return-from draw-cursor))
  174.     (draw-rectangle window gcontext cursor-x rectangle-y width height fill-p)))
  175.  
  176. (defmethod stream-clear-input ((self interactive-stream))
  177.   "Clear all input that hasn't been read yet from the current io-buffer."
  178.   (setf (slot-value (the interactive-stream self) 'unreadp) nil)
  179.   (clear-characters (contact-display self))
  180.   (loop  ;; Eat any characters sitting in the event buffer
  181.     (unless (read-character (contact-display self) 0)
  182.       (return nil))))
  183.  
  184. (defmethod stream-unread-char ((self interactive-stream) character)
  185.   "Put CHARACTER back in the io-buffer so that it will be the next
  186. character returned by ANY-TYI.  Note that CHARACTER must be exactly the
  187. last character that was read, and that it is illegal to do two
  188. unread-char's in a row."
  189.   (setf (slot-value (the interactive-stream self) 'unreadp) t)
  190.   (unread-character (contact-display self) character))
  191.  
  192. ;; for common-windows compatibility
  193. (defun force-input (contact string &key (begin 0) end)
  194.   "Forces the characters from BEGIN to END in STRING into the input buffer for CONTACT."
  195.   (append-characters (contact-display contact) string begin end))
  196.  
  197. (defmethod stream-listen ((self interactive-stream))
  198.   "If a character is waiting in the current io-buffer, return it
  199. leaving the character in the buffer.  If no character is available, return NIL."
  200.   (listen-character (contact-display self)))
  201.  
  202. (defmethod stream-peek-char ((self interactive-stream) peek-type)
  203.   (let (char)
  204.     (loop
  205.       (setq char (stream-read-char self))
  206.       (cond ((null peek-type) (return nil))
  207.         ((eq peek-type t)
  208.          (unless (member char '(#\space #\tab #\newline)) (return nil)))
  209.         ((char= char peek-type) (return nil)))
  210.       (stream-unread-char self char))
  211.     char))
  212.  
  213. (defmethod stream-read-char ((self interactive-stream))
  214.   "Read a character from the keyboard.
  215.  Echoing is handled by the rubout handler (see rh-read-char)"
  216.   (declare (special *rubout-handler*))
  217.   (reset-more-height self)
  218.   (let (char)
  219.     (cond ((slot-value (the interactive-stream self) 'unreadp)
  220.        (setf (slot-value (the interactive-stream self) 'unreadp) nil)
  221.        (setq char (read-character (contact-display self))))
  222.       ((eq *rubout-handler* 'tyi)
  223.        (setq char (read-character (contact-display self))))
  224.       (*rubout-handler*
  225.        (setq char (rh-read-char self)))
  226.       (t (setq char (read-character (contact-display self)))
  227.          ;; Note: characters are not echoed without a rubout handler
  228.          ))
  229.     #+ti
  230.     (handle-asynchronous-characters char self)
  231.     char))
  232.  
  233. (defmethod reset-more-height ((self interactive-stream))
  234.   (with-slots (height more-height line-height) self
  235.     (when more-height           ;; Reset MORE height
  236.       (setf more-height (- height (* 2 line-height))))))
  237.  
  238. (defmethod stream-read-line ((self interactive-stream) &rest make-array-options)
  239.   (do ((line nil (cons (stream-read-char self) line)))
  240.       ((eql (car line) #\newline)
  241.        (let* ((i (1- (length line)))
  242.           (result (apply #'make-array i :element-type 'string-char
  243.                  make-array-options)))
  244.      (dolist (c (cdr line))
  245.        (setf (aref result (decf i)) c))
  246.      result))))
  247.  
  248.  
  249. (defun set-cursorpos (interactive-stream &key x y)
  250.   (with-slots (cursor-x cursor-y gcontext)
  251.           (the interactive-stream interactive-stream)
  252.     (draw-cursor interactive-stream cursor-x cursor-y gcontext :erase-p t)
  253.     (when x
  254.       (setf cursor-x x))
  255.     (when y
  256.       (setf cursor-y y))
  257.     (draw-cursor interactive-stream cursor-x cursor-y gcontext :fill-p t))
  258.   ;; needs to move a cursor character around
  259.   )
  260.  
  261.  
  262. ;;;-----------------------------------------------------------------------------
  263. ;;; Output
  264.  
  265. (defvar *no-stream-history-p* nil) ;; Bound to T during display
  266.  
  267. (defmethod display ((self interactive-stream) &optional x y width height &key)
  268.   (declare (ignore x y width height))
  269.   (let ((win self))
  270.     (clear-area win)
  271.     (with-slots (cursor-x cursor-y line-height font gcontext
  272.               output-history output-history-top) self
  273.       (setf cursor-x 0
  274.         cursor-y (- line-height (max-char-descent font)))
  275.       ;;display the cursor
  276.       (draw-cursor self cursor-x cursor-x gcontext :fill-p t)
  277.       (do ((history output-history-top (cdr history))
  278.        (*no-stream-history-p* t))
  279.       ((eq history output-history))
  280.     (draw-cursor self cursor-x cursor-y gcontext :erase-p t)
  281.     (stream-write-string self (car history))
  282.     (setf cursor-x 0
  283.           cursor-y (+ cursor-y line-height))
  284.     (draw-cursor self cursor-x cursor-y gcontext)))
  285.     ))
  286.  
  287. (defmethod stream-clear-output ((self interactive-stream))
  288.   (with-slots ( output-history output-history-size output-history-top
  289.            font height cursor-x cursor-y more-height line-height gcontext) self
  290.     (do ((i output-history-size (1- i))
  291.      (history output-history (cdr history)))
  292.     ((zerop i))
  293.       (when (car history)
  294.     (setf (fill-pointer (car history)) 0)))
  295.     (setf cursor-x 0
  296.       cursor-y (- line-height (max-char-descent font)))
  297.     (reset-more-height self)
  298.     (setf output-history-top output-history)
  299.     (clear-area self)
  300.     (draw-cursor self cursor-x cursor-y gcontext))
  301.   nil)
  302.  
  303. (defmethod stream-move-cursor ((self interactive-stream) &optional x y)
  304.   (with-slots (cursor-x cursor-y gcontext font) self
  305.     (let ((oldx cursor-x)
  306.       (oldy cursor-y))
  307.       (when x (setf cursor-x x))
  308.       (when y (setf cursor-x x))
  309.       (let ((newx cursor-x)
  310.         (newy cursor-y))
  311.     (draw-cursor self oldx oldy gcontext :erase-p t)
  312.     (draw-cursor self newx newy gcontext :fill-p t)
  313.     ;; ********************* NEED TO ADD CURSOR OBJECT *****************
  314.     newx newy oldx oldy nil
  315.     ))))
  316.  
  317. (defmethod stream-write-char ((self interactive-stream) character)
  318.   (when (integerp character)           ;; Kludge for old zetalisp code
  319.     (setq character (int-char character)))
  320.   (with-slots ( cursor-x cursor-y
  321.            (contact-width width) (contact-height height)
  322.            gcontext font more-height line-height
  323.            output-history  tab-width lozenge-font) self
  324.     (draw-cursor self cursor-x cursor-y gcontext :erase-p t) 
  325.     (if (graphic-char-p character)
  326.     (progn
  327.       (when (> cursor-x contact-width) ;; Wrap on wide lines
  328.         (stream-write-char self #\newline))
  329.       (let ((width (char-width font (char-int character))))
  330.         (draw-glyph self gcontext cursor-x cursor-y (char-int character)
  331.             :width width :size 8 :translate #'xlib::translate-default)
  332.         (incf cursor-x width)
  333.         (unless *no-stream-history-p*
  334.           (vector-push-extend character (car output-history)))))
  335.       (progn ;; Undrawable character
  336.     (case character
  337.       (#\newline (setf cursor-x 0
  338.                cursor-y (+ cursor-y line-height))
  339.              (unless *no-stream-history-p*
  340.                (pop output-history)
  341.                (unless (car output-history)
  342.              (setf (car output-history)
  343.                    (make-array 256 :fill-pointer 0 :element-type 'string-char :adjustable t)))
  344.                (setf (fill-pointer (car output-history)) 0))
  345.              (when (> (+ cursor-y (max-char-descent font)) contact-height)
  346.                (when *no-stream-history-p*
  347.              (error "EOP during refresh")) ;; should never get here...
  348.                (end-of-page self))
  349.              (when (and more-height
  350.                 (minusp (decf more-height line-height)))
  351.                (more-processing self)))
  352.       (#\backspace (let ((width (char-width font (font-default-char font))))
  353.           (setf cursor-x (max 0 (- cursor-x width))))
  354.         (unless *no-stream-history-p*
  355.           (vector-push-extend character (car output-history))))
  356.       (#\tab (setf cursor-x (+ cursor-x tab-width))
  357.          (unless *no-stream-history-p*
  358.            (vector-push-extend character (car output-history))))
  359.       (otherwise
  360.        (unless *no-stream-history-p*
  361.          (vector-push-extend character (car output-history)))
  362.        (incf cursor-x
  363.          (draw-lozenged-string self gcontext cursor-x cursor-y
  364.                        (string (or (char-name character)
  365.                            (format nil "~:@C" (char-int character))))
  366.                        lozenge-font))))))
  367.     (draw-cursor self cursor-x cursor-y gcontext))
  368.   character)
  369.  
  370. (defmethod end-of-page ((interactive-stream interactive-stream))
  371.   ;; Scroll up one line
  372.   (with-slots (cursor-x cursor-y height width line-height output-history-top (gc gcontext))
  373.           (the interactive-stream interactive-stream)
  374.     (let* ((bottom-line (min cursor-y height))
  375.        (clear-height (- height bottom-line)))
  376.       (copy-area interactive-stream gc 0 line-height width bottom-line
  377.          interactive-stream 0 0)
  378.       (when (plusp clear-height)
  379.     (clear-area interactive-stream :x 0 :y bottom-line
  380.             :width width :height clear-height))
  381.       (pop output-history-top))
  382.     (decf cursor-y line-height)
  383.     (draw-cursor interactive-stream cursor-x cursor-y gc)))
  384.  
  385. (defun more-processing (interactive-stream)
  386.   (reset-more-height interactive-stream)
  387.   (let ((*no-stream-history-p* t))
  388.     (stream-write-string interactive-stream "*** MORE ***")
  389.     (display-force-output (contact-display interactive-stream))
  390.     (stream-read-char interactive-stream)
  391.     (clear-line interactive-stream)))
  392.   
  393. (defun clear-line (interactive-stream)
  394.   ;; Clear the current line
  395.   (setf (slot-value (the interactive-stream interactive-stream) 'cursor-x) 0)
  396.   (clear-eol interactive-stream))
  397.  
  398. (defun clear-eol (interactive-stream)
  399.   ;; Clear the current line starting at the current cursor-x
  400.   (with-slots (font cursor-x cursor-y line-height width line-height gcontext)
  401.           (the interactive-stream interactive-stream)
  402.     (clear-area interactive-stream :x cursor-x :y (+ (font-descent font)
  403.                              (- cursor-y line-height))
  404.         :width width :height  line-height)
  405.     (draw-cursor interactive-stream cursor-x cursor-y gcontext)))
  406.  
  407. (defmethod stream-write-string ((self interactive-stream) string &optional (start 0) end)
  408.   (unless end (setq end (length string)))
  409.   (do ((i start (+ i index 1))
  410.        (index 0))
  411.       ((>= i end) string)
  412.     (declare (type integer i)
  413.          (type (or null integer) index))
  414.     (with-slots ((contact-width width)
  415.          cursor-x cursor-y
  416.          font gcontext output-history) self
  417.       (draw-cursor self cursor-x cursor-y gcontext :erase-p t)
  418.       (when (> cursor-x contact-width) ;; Wrap on wide lines
  419.     (stream-write-char self #\newline))
  420.       (let ((line-width (- contact-width cursor-x))
  421.         (string-width 0)
  422.         (new-end end))
  423.     (multiple-value-setq (string-width index)
  424.       (text-width font string :start i :end end))
  425.     (when index (setq new-end index))
  426.     (when (> string-width line-width) ;; Clip strings longer than remaing line width
  427.       (setq new-end (text-within-width line-width font string :start i :end new-end)
  428.         string-width line-width))
  429.     (setq index
  430.           (draw-glyphs self gcontext cursor-x cursor-y
  431.                string :start i :end new-end :width string-width))
  432.     (incf cursor-x string-width))
  433.       (draw-cursor self cursor-x cursor-y gcontext)
  434.       ;; Save history
  435.       (unless *no-stream-history-p*
  436.     (let* ((history (car output-history))
  437.            (j (fill-pointer history))
  438.            (l (or index end))
  439.            (h (+ j (- l i))))
  440.       ;; Grow history if necessary
  441.       (when (> h (array-total-size history))
  442.         (setq history (adjust-array history (+ h 80)))
  443.         (setf (car output-history) history))
  444.       (setf (fill-pointer history) h)
  445.       (replace history string :start1 j :end1 h :start2 i :end2 l)))
  446.       ;; do special characters not printed
  447.       (if index
  448.       (stream-write-char self (aref string index))
  449.     (return string)))))
  450.  
  451. (defun text-within-width (width font string &key (start 0) end translate)
  452.   "Return an index within STRING such that the string width is less than WIDTH"
  453.   ;; Estimate size
  454.   (do* ((index (+ start (ceiling width (min-char-width font))) (1+ index))
  455.     (stop (or end (length string))))
  456.        ((>= index stop) index)
  457.     (multiple-value-bind (w i)
  458.     (text-width font string :start start :end index :translate translate)
  459.       (when i (return i))
  460.       (when (> w width) (return (1- index))))))
  461.  
  462. (defmethod stream-fresh-line ((self interactive-stream))
  463.   (with-slots (output-history) self
  464.     (unless (or (null (car output-history))
  465.         (zerop (length (car output-history))))
  466.       (stream-write-char self #\newline))))
  467.  
  468. ;;;--------------------------------------------------------------------------------------------
  469. ;;; LOZENGED-STRINGS
  470.  
  471. (defun draw-lozenged-string (window gcontext x0 y0 string font)
  472.   "Display string inside a lozenge at X0 Y0."
  473.   (declare (values right-coordinate bottom-coordinate))
  474.   (multiple-value-bind (width ascent descent)
  475.       (text-extents font string)
  476.     (let* (;; Put 2 pixels to the top and bottom of the string.
  477.        (lozenge-height (+ ascent 4))
  478.        (wid (+ lozenge-height width))
  479.        (xpos (+ x0 (ceiling lozenge-height 2)))
  480.        (ypos (+ y0 descent)))
  481.       ;; Put the string then the box around it.
  482.       (using-gcontext (gc :drawable (contact-root window) :default gcontext :font font)
  483.     (draw-glyphs window gc xpos ypos string))
  484.       (draw-lozenge window gcontext wid lozenge-height x0 (- y0 ascent 2))
  485.       (values wid lozenge-height))))
  486.  
  487. (defun draw-lozenge (window gcontext width height x y)
  488.   "Draw a hollow lozenge on WINDOW.
  489.  (a LOZENGE is a rectangle whose left and right ends are <pointed>.
  490. A lozenge whose width and height are equal is a diamond shape.)"
  491.   (let* ((hh (floor (1- height) 2))
  492.      (cy (+ y hh    hh))
  493.      (cx (+ x width -1)))
  494.     (draw-lines window gcontext (list
  495.                 ;;                        ; _
  496.                 ;;                        ;/ \  This looks like
  497.                 ;;                        ;\_/  what we are drawing
  498.         x         (+ y hh)
  499.         (+  x hh) y          ;/
  500.         (- cx hh) y          ; _
  501.         cx        (+ y hh)      ;  \
  502.         (- cx hh) cy          ;  /
  503.         (+  x hh) cy          ; _
  504.         x         (+ y hh)))      ;\
  505.     ))
  506.  
  507.  
  508. ;;;-----------------------------------------------------------------------------
  509. ;;; Alas, Common-lisp doesn't specify a portable way to make your own stream object.
  510. ;;; Here is a zetalisp implementation for lisp machines using clos-kludge.
  511. ;;; PLEASE mail an implementation for YOUR lisp to clue-review@dsg.csc.ti.com
  512. #+(and lispm (not clos))
  513. (defun (:property interactive-stream si:named-structure-invoke)
  514.        (method self &rest args
  515.     &aux (operations '( :which-operations :operation-handled-p :send-if-handles
  516.                :print-self :listen :clear-input :untyi :tyi :line-in
  517.                :clear-screen :tyo :string-out :fresh-line :rubout-handler :clear-eol)))
  518.   (ecase method
  519.     (:which-operations operations)
  520.     (:operation-handled-p (member (first args) operations))
  521.     (:send-if-handles (when (member (first args) operations)
  522.             (apply self args)))
  523.     (:print-self (format (first args) "#<interactive-stream ~o>" (si:%pointer self)))
  524.     (:listen (apply #'stream-listen self args))
  525.     (:clear-input (apply #'stream-clear-input self args))
  526.     (:untyi (apply #'stream-unread-char self args))
  527.     ((:tyi :any-tyi) (stream-read-char self))
  528.     (:line-in (let ((leader (car args)))
  529.         (stream-read-line self :leader-length (and (numberp leader) leader))))
  530.     (:clear-screen (apply #'stream-clear-output self args))
  531.     (:tyo (apply #'stream-write-char self args))
  532.     (:string-out (apply #'stream-write-string self args))
  533.     (:fresh-line (apply #'stream-fresh-line self args))
  534.     (:clear-eol (apply #'clear-eol self args))
  535.     (:force-output (display-force-output (contact-display self)))
  536.     (:finish (display-finish-output (contact-display self)))
  537.     (:rubout-handler (apply #'stream-rubout-handler self args))
  538.  
  539. ;;    #+ti (:preemptable-read (apply #'stream-rubout-handler self args))
  540.     #+ti (:read-cursorpos (values 0 0))
  541.     #+ti (:process si:current-process)
  542.     ))
  543.  
  544. #+(and Explorer CLOS)
  545. (progn
  546. (defmethod (interactive-stream :clear-eol) ()
  547.   (clear-eol zl:self))
  548.  
  549. (defmethod (interactive-stream :line-in) (&optional leader)
  550.   (stream-read-line zl:self :leader-length (and (numberp leader) leader)))
  551.  
  552. (defmethod ticlos:stream-read-line ((stream interactive-stream))
  553.   (stream-read-line stream))
  554.  
  555. (defmethod ticlos:stream-read-char-no-hang ((self interactive-stream))
  556.   (and (listen-character (contact-display self))
  557.        (stream-read-char self)))
  558.  
  559. (defmethod ticlos:stream-force-output ((stream interactive-stream))
  560.   (display-force-output (contact-display stream)))
  561.  
  562. (defmethod ticlos:stream-finish-output ((stream interactive-stream))
  563.   (display-finish-output (contact-display stream)))
  564.  
  565. (defmethod ticlos:stream-line-column ((stream interactive-stream))
  566.   (values (zl:send stream :read-cursorpos ':character)))
  567.  
  568. (defmethod ticlos:stream-start-line-p ((stream interactive-stream))
  569.   (zerop (slot-value stream 'cursor-x)))
  570.  
  571. (defmethod (interactive-stream :read-cursorpos) (&optional units)
  572.   (declare (notinline char-width))
  573.   (if (eq units ':character)
  574.       (values (round cursor-x (char-width font (char-int #\n)))
  575.           (round cursor-y line-height))
  576.     ;; else assume pixels
  577.     (values cursor-x cursor-y)))
  578.  
  579. (defmethod (interactive-stream :increment-cursorpos) (dx dy &optional units)
  580.   (declare (notinline char-width))
  581.   (if (eq units ':character)
  582.       (stream-move-cursor zl:self (+ cursor-x (* dx (char-width font (char-int #\n))))
  583.               (+ cursor-y (* dy line-height)))
  584.     ;; else assume pixels
  585.     (stream-move-cursor zl:self (+ cursor-x dx) (+ cursor-y dy))))
  586.  
  587. (defmethod (interactive-stream :process) () si:current-process)
  588.  
  589.   ) ; end Explorer and CLOS
  590.  
  591.  
  592. ;;-----------------------------------------------------------------------------
  593. ;; A SIMPLE rubbout handler
  594. ;;        (what an understatement, but it's something to build on...)
  595.  
  596.  
  597. (defmacro with-input-editing ((stream &optional rubout-options) &body body)
  598.   "Execute BODY inside of STREAM's stream-rubout-handler method.
  599. If BODY does input from STREAM, it will be done with rubout processing
  600. if STREAM is an interactive-stream.
  601. RUBOUT-OPTIONS should be the options for the stream-rubout-handler method"
  602.   (unless stream (setq stream '*standard-input*))
  603.   `(stream-rubout-handler ,stream ,rubout-options
  604.               #'(lambda () ,@body)))
  605.  
  606. (defun stream-rubout-handler (contact options function &rest args)
  607.   ;; Rubout handling in the zetalisp tradition
  608.   (if (typep contact 'interactive-stream)
  609.       (let ((option-plist nil))
  610.     (dolist (option options)
  611.       (setq option-plist (append option-plist option)))
  612.     (if args
  613.         (funcall (stream-rubout-handler-function contact) contact option-plist
  614.              #'(lambda () (apply function args)))
  615.       (funcall (stream-rubout-handler-function contact) contact option-plist function)))
  616.     (apply function args)))
  617.  
  618. (defmacro rubout-handler (&rest options &key (stream *terminal-io*) body
  619.               pass-through do-not-echo help initial-input)
  620.   "Common-windows rubout-hander"
  621.   (declare (ignore pass-through do-not-echo help initial-input))
  622.   (let ((option-plist (copy-list options)))
  623.     (remf option-plist :stream)
  624.     (remf option-plist :body)
  625.     `(rubout-handler-internal ,stream #'(lambda () ,body) ,@option-plist)))
  626.  
  627. (defun rubout-handler-internal (contact function &rest options)
  628.   ;; Rubout handling in the common-windows tradition
  629.   (if (typep contact 'interactive-stream)
  630.       ;; Note: OPTIONS doesn't have to be copied, even though it's an &rest arg,
  631.       ;; because it's never referenced outside this dynamic scope.
  632.       (funcall (stream-rubout-handler-function contact) contact options function)
  633.     (funcall function)))
  634. ;;
  635. ;; Rubout-Handler-Buffer
  636. ;;
  637. (defstruct (rubout-handler-buffer (:conc-name rhb-))
  638.   (fill-pointer   0)
  639.   (scan-pointer   0)
  640.   (buffer (make-array 128 :element-type 'string-char))
  641.   (options nil))
  642.  
  643. ;; Since it doesn't make much sense for a process to get input from more
  644. ;; than one stream at a time, This rubout handler implementation doesn't
  645. ;; allocate a rubout-handler-buffer for each stream.  Instead, a cache
  646. ;; of buffers is kept, and the rubout-handler-buffer is bound to *rhb*
  647. ;; within the scope of the rubout handler, instead of in a slot of the
  648. ;; stream.
  649.  
  650. (defvar *rhb* nil) ;; rubout-handler-buffer
  651. (defvar *rhb-cache* nil) ;; rubout handler buffer cache
  652.  
  653. (defun allocate-rhb ()
  654.   (or (xlib::atomic-pop *rhb-cache*)
  655.       (make-rubout-handler-buffer)))
  656.  
  657. (defun deallocate-rhb (rhb)
  658.   (setf (rhb-options rhb) nil) ;; Zap options for garbage collection
  659.   (xlib::atomic-push rhb *rhb-cache*))
  660.  
  661. (defun get-rubout-handler-buffer (stream)
  662.   "Return a string that represents the current state of
  663.  the rubout handler associated with STREAM.
  664.  This must be called from within the BODY passed to rubout handler."
  665.   (declare (ignore stream))
  666.   ;; We keep the rubout-handler-buffer in *RHB*, NOT in a slot of the stream.
  667.   (subseq (rhb-buffer *rhb*) 0 (rhb-fill-pointer *rhb*)))
  668.  
  669. ;; *RUBOUT-HANDLER* keeps track of the state of the rubout handler.  It can have
  670. ;; one of the following settings:
  671. ;;
  672. ;;    NIL    Outside the rubout handler
  673. ;;    READ    Inside the rubout-handler but not inside rubout-handler-edit
  674. ;;    TYI    Inside rubout-handler-edit
  675. ;;
  676. ;; This variable is bound back to NIL whenever entering a new listener loop
  677. ;; which establishes its own editing context.
  678. (defvar *rubout-handler* nil "Rubout handler state. NIL when not INSIDE the rubout handler")
  679.  
  680. (defun simple-rubout-handler (contact options function)
  681.   ;; A rubout handler in the common-windows tradition
  682.   ;; Options include:
  683.   ;; :full-rubout flag    If the user erases all of the characters then presses
  684.   ;;                      the rubout character once more, control is returned
  685.   ;;              from the input editor immediately.  Two values are
  686.   ;;              returned: NIL and FLAG.  In the absence of this option,
  687.   ;;              the input editor simply waits for more characters.
  688.   ;;
  689.   ;; :prompt string      string to display or function of one argument (the contact)
  690.   ;; :reprompt string
  691.   ;; :initial-input string
  692.   ;; :initial-input-pointer card16
  693.   (let ((*rhb* (allocate-rhb)))
  694.     (unwind-protect
  695.     (progn
  696.       (setf (rhb-options *rhb*) options)
  697.       (setf (rhb-fill-pointer *rhb*) 0)       ; number of characters in the buffer
  698.       (setf (rhb-scan-pointer *rhb*) 0)       ; number of characters sent to application
  699.  
  700.       ;; PROMPT option
  701.       (let ((prompt-option (getf options :prompt)))
  702.         (cond ((null prompt-option))
  703.           ((stringp prompt-option)
  704.            (stream-write-string contact prompt-option))
  705.           #+explorer ;; explorer error-handler hack
  706.           ;; old zetalisp required 2 arguments to prompt and read.
  707.           ((eq prompt-option 'sys:prompt-and-read-prompt-function)
  708.            (funcall prompt-option contact nil))
  709.           (t (funcall prompt-option contact))))
  710.  
  711.       ;; INITIAL-INPUT option
  712.       (let ((initial-input (getf options :initial-input)))
  713.         (when initial-input
  714.           (let* ((initial-input-pointer (getf options :initial-input-pointer 0))
  715.              (length (- (length initial-input) initial-input-pointer))
  716.              (size (array-total-size (rhb-buffer *rhb*))))
  717.         (when (> length size)
  718.           (setf (rhb-buffer *rhb*) (adjust-array (rhb-buffer *rhb*) (+ length size))))
  719.         (replace (rhb-buffer *rhb*) initial-input :start1 initial-input-pointer)
  720.         (setf (rhb-fill-pointer *rhb*) length)
  721.         (stream-write-string contact initial-input initial-input-pointer))))
  722.  
  723.       (when (slot-value (the interactive-stream contact) 'unreadp) ; Make sure type ahead is processed
  724.         (simple-rubout-handler-edit contact)            ; by rubout handler, not just by TYI
  725.         (setf (rhb-scan-pointer *rhb*) 0))
  726.       (do ((*rubout-handler* 'read)       ;Establish rubout handler
  727.            #+ti (si:rubout-handler t)  ;Needed for explorer compatability
  728.            )
  729.           (nil)
  730.         (catch 'rubout-handler        ; Throw here when rubbing out
  731.           (progn
  732.         #+cleh                ; Hopefully, someday everyone will use this
  733.         (conditions:handler-case
  734.             (return (funcall function))
  735.           (error (condition) (princ condition)))
  736.         #+(and lispm (not cleh))
  737.         (si:catch-error            ; If a read-error occurs, print a message and loop back
  738.           (return            ; Exit rubbout handler when read function returns
  739.             (funcall function)))    ; Call read function
  740.         #+(and kcl (not cleh))
  741.         (multiple-value-bind (tag value)
  742.             (si:error-set `(funcall ',function))
  743.           (unless tag (return value)))
  744.         #+(and excl (not cleh))
  745.         (multiple-value-bind (tag value)
  746.             (excl:error-set (funcall function) :announce)
  747.           (unless tag (return value)))
  748.         #-(or cleh lispm kcl excl)
  749.         (return (funcall function))
  750.         ;; We come here after read errors (catch-error caught)
  751.         (fresh-line contact)        ; Echo the rubout handler buffer
  752.         (stream-write-string contact (rhb-buffer *rhb*) 0 (rhb-fill-pointer *rhb*))
  753.         (loop (stream-read-char contact))))    ; and force user to edit it
  754.         ;; Come here on throw to 'rubout-handler
  755.         ;; Maybe return when user rubs all the way back
  756.         (and (zerop (rhb-fill-pointer *rhb*))
  757.          (let ((full-rubout-option (getf options :full-rubout)))
  758.            (and full-rubout-option (return (values nil full-rubout-option)))))))
  759.       (deallocate-rhb *rhb*))))
  760.  
  761. (defun rh-read-char (contact &aux idx)
  762.   ;; Get the next character from the rubout-handler buffer, or the user
  763.   ;; Called from stream-read-char when *rubout-handler* is 'read
  764.   (cond ((> (rhb-fill-pointer *rhb*)       ;Return characters from rhb until end of buffer
  765.         (setq idx (rhb-scan-pointer *rhb*)))
  766.      (setf (rhb-scan-pointer *rhb*) (1+ idx))
  767.      (aref (rhb-buffer *rhb*) idx))
  768.     (t (simple-rubout-handler-edit contact)))    ;Else, editing the buffer
  769.   )
  770.  
  771. (defun simple-rubout-handler-edit (contact)
  772.   ;; This is the "guts" of the rubout handler, where the editing occurs
  773.   ;; This needs LOTS more editing commands!
  774.   (do ((rubbed-out-some nil)
  775.        (*rubout-handler* 'tyi)
  776.        (ch))
  777.       (nil) ;; forever
  778.     (setq ch (stream-read-char contact))
  779.     (case ch
  780.       (#\control-u                ;CLEAR-INPUT flushes all buffered input
  781.        (setf (rhb-fill-pointer *rhb*) 0)
  782.        (setq rubbed-out-some t)            ;Will need to throw out
  783.        (stream-write-char contact ch)        ;Echo and advance to new line
  784.        (stream-write-char contact #\Newline))
  785.       (#\control-l                ;Retype buffered input
  786.        (display contact)
  787.        (let ((prompt (or (getf (rhb-options *rhb*) :reprompt)
  788.              (getf (rhb-options *rhb*) :prompt))))
  789.      (cond ((null prompt))
  790.            ((stringp prompt)
  791.         (stream-write-string contact prompt))
  792.            #+explorer ;; explorer error-handler hack
  793.            ;; old zetalisp required 2 arguments to prompt and read.
  794.            ((eq prompt 'sys:prompt-and-read-prompt-function)
  795.         (funcall prompt contact nil))
  796.            (t
  797.         (funcall prompt contact))))
  798.        (stream-write-string contact (rhb-buffer *rhb*) 0 (rhb-fill-pointer *rhb*)))
  799.       (#\Rubout
  800.        (let ((len (rhb-fill-pointer *rhb*)))
  801.      (unless (zerop len)
  802.        (setf (rhb-fill-pointer *rhb*) (setq len (1- len)))
  803.        (set-cursorpos contact :x (- (stream-cursor-x contact)
  804.                     (char-width (stream-font contact)
  805.                             (char-int (aref (rhb-buffer *rhb*) len)))))
  806.        (clear-eol contact)
  807.        (setq rubbed-out-some t)
  808.        (when (zerop len) ;; when all rubbed out
  809.          (setf (rhb-scan-pointer *rhb*) 0)
  810.          (throw 'rubout-handler t)))))
  811.       (otherwise
  812.        (if (plusp (char-bits ch))
  813.        (bell (contact-display contact)) ;; unknown command
  814.      ;; Echo character
  815.      (let ((fill-pointer (rhb-fill-pointer *rhb*)))
  816.        (stream-write-char contact ch)
  817.        ;; Put character in buffer, after first ensuring its big enough
  818.        (when (> (setf (rhb-fill-pointer *rhb*) (1+ fill-pointer))
  819.             (array-total-size (rhb-buffer *rhb*)))
  820.          (setf (rhb-buffer *rhb*)
  821.            (adjust-array (rhb-buffer *rhb*) (* 2 fill-pointer))))
  822.        (setf (aref (rhb-buffer *rhb*) fill-pointer) ch)
  823.        (cond (rubbed-out-some
  824.           ;; Make the reader closure re-read all input from the beginning
  825.           (setf (rhb-scan-pointer *rhb*) 0)
  826.           (throw 'rubout-handler t))
  827.          (t
  828.           ;; New character at the end of the buffer, just return it.
  829.           (setf (rhb-scan-pointer *rhb*) (rhb-fill-pointer *rhb*))
  830.           (return ch)))))))))
  831. #+ti
  832. (defun handle-asynchronous-characters (char contact)
  833.   ;; This handles things like abort, break, system and terminal for TI Explorers
  834.   (let ((entry (assoc char tv:kbd-intercepted-characters)))
  835.     (cond (entry (funcall (second entry) char))
  836.       ((setq entry (assoc char tv:kbd-global-asynchronous-characters))
  837.        (funcall (second entry) char contact))
  838.       ((setq entry (assoc char tv:kbd-standard-asynchronous-characters))
  839.        (funcall (second entry) char contact)))))
  840.